home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / TURB_VIS / RESDMP11 / RESDUMP.PAS < prev    next >
Pascal/Delphi Source File  |  1993-07-26  |  25KB  |  710 lines
  1. {$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,R+,S+,T-,V+,X+,Y-}
  2. {$M 16384,0,655360}
  3. { W. Gross, April 1992,
  4.   Vs. 1.1, last change: 26-JUL-93}
  5.  
  6. {handles only objects
  7.    TMenuBar, TStatusLine, TStringList and
  8.    TDialog with these imbedded controls:
  9.          TView, TButton, TRadioButton, TCheckBoxes,THistory,
  10.          TInputLine, TParamText, TListViewer, TStaticText.
  11.  
  12.   Program cannot correctly recover the heap, if unregistered
  13.   objects are encountered inside TDialog objects.
  14.  
  15.          }
  16.  
  17.  
  18. program ResDump;
  19.   uses Crt,Dos,Objects,Drivers,Views,Menus,Dialogs,Memory,
  20.   GADGETS, MSGBOX, STDDLG, RESDUTIL, DRESFU, App;
  21.  
  22.   const
  23.     cmAboutDialog =  101;
  24.     cmDumpDialog  =  111;
  25.     cmNewOutFileD =  121;
  26.     cmDoubleClick =  130;
  27.     cmDAll        =  131;
  28.     cmDDialog     =  132;
  29.     cmDMenubar    =  133;
  30.     cmDStatusline =  134;
  31.     cmDStringList =  135;
  32.     cmDFI         =  136;
  33.  
  34.     hcResList     =  1138;
  35.     hcOutFile     =  1121;
  36.     hcResFile     =  1111;
  37.  
  38.     {change these constants as convenient                            +++}
  39.     cmStartScrnSaver = 200;                                         {+++}
  40.     cmStopScrnSaver  = 201;                                         {+++}
  41.     {your favorite text here}
  42.     ScrnSaverText : String = 'RESDUMP lurking ...' ;                {+++}
  43.     GracePeriod : longint = 5000; {ask DOS time after graceperiod}  {+++}
  44.     {all time values in centiseconds                                 +++}
  45.     {Invoke screen saver after program is idle for ScrnSaverDelay centisecs}
  46.     ScrnSaverDelay : longint = 6000;                                {+++}
  47.     ScrnSaverInt   : longint = 500;                                 {+++}
  48.  
  49.   type
  50.     PFileStatusBox = ^TFileStatusBox;
  51.     TFileStatusbox = object (TView)
  52.       procedure draw ; virtual;
  53.      END;
  54.  
  55.     PWaitDialog = ^TWaitDialog;
  56.     TWaitDialog = object (TDialog)
  57.       function getpalette : PPalette; virtual;
  58.      END;
  59.  
  60.     TMyApp = object(TApplication)
  61.       ScrnSaverKickTime,                                            {+++}
  62.       ScrnSaverLastTime : longint; {centiseconds}                   {+++}
  63.       ScrnSaverMode : boolean;                                      {+++}
  64.       GraceCounter : word; {ask DOS time only if > GracePeriod}     {+++}
  65.  
  66.       OutFileName,ResFileName : PathStr;
  67.       OutFileOpen, ResFileOpen : boolean;
  68.       Heap       : PHeapView;
  69.       Clock      : PClockView;
  70.       FBox       : PFileStatusBox;
  71.       constructor Init;
  72.       destructor  Done; virtual;
  73.       procedure   InitMenuBar; virtual;
  74.       procedure   GetEvent(var Event: TEvent); virtual;
  75.       procedure   HandleEvent(var Event: TEvent); virtual;
  76.       procedure   InitStatusLine; virtual;
  77.       procedure   Idle; virtual;
  78.       function    GetPalette: PPalette;virtual;
  79.       procedure   AboutDialog;
  80.       procedure   DumpDialog;
  81.       procedure   OutFileDialog;
  82.     end;
  83.  
  84.     PClickListBox = ^TClickListBox;
  85.     TClickListBox = object (TListBox)
  86.       procedure HandleEvent (Var Event : TEvent ); virtual;
  87.       END;
  88.  
  89.     PResDialog = ^TResDialog;
  90.     TResDialog = object (TDialog)
  91.       ResFileName : PathStr;
  92.       RLB         : PClickListBox;
  93.       Collection  : PStringCollection;
  94.       PROCEDURE  RestInit ( FName : PathStr );
  95.       procedure  HandleEvent ( VAR Event : TEvent ); virtual;
  96.       procedure  InitCollection;
  97.       destructor done;virtual;
  98.       END;
  99.  
  100.     PMyStatusLine = ^TMyStatusLine;
  101.     TMyStatusLine  = object (TStatusLine)
  102.       FUNCTION Hint (AHelpCtx : Word ) : String ; VIRTUAL;
  103.       END;
  104.  
  105.  
  106.   VAR
  107.     MyApp : TMyApp;
  108.     outfile : text;
  109.     BufStream,MyAppResStream : PBufStream;
  110.     MyAppResFile, ResFile : TResourceFile;
  111.     WaitBox : PDialog;
  112.     EXEName,BRSName : PathStr;
  113.     Ed : DirStr; En : NameStr; Ee : ExtStr;
  114.     HCTEXT_SL : PStringList;
  115.  
  116.  
  117. FUNCTION Time:longint;                     {+++ we need this function +++}
  118.   {Return real day time in centiseconds. One might get in trouble with
  119.    measurements spanning midnight. Smallest reliable interval: 55 msec}
  120.   VAR Hour,Minute,Second,Sec100: WORD;                               {+++}
  121.   BEGIN                                                              {+++}
  122.     GetTime(Hour,Minute,Second,Sec100);                              {+++}
  123.     Time:=longint(Sec100)+100*(longint(Second)                       {+++}
  124.           +60*(longint(Minute)+60*longint(hour)));                   {+++}
  125.   END;                                                               {+++}
  126.  
  127. { TMyStatusLine }
  128.  
  129.   FUNCTION TMyStatusLine.Hint(AHelpCtx : Word ) : String ;
  130.     VAR s : String[80];
  131.     BEGIN
  132.       s := '';
  133.       IF HCTEXT_SL<>NIL THEN
  134.         s := HCTEXT_SL^.Get(AHelpCtx);
  135.       IF s='' THEN
  136.         BEGIN str ( AHelpCtx, s ); s := 'hcxxxx='+s; END; {!change!}
  137.       Hint := s;
  138.     END; {FUNC TMyStatusLine.Hint}
  139.  
  140.  
  141. { TResDialog }
  142.  
  143.   PROCEDURE TResDialog.InitCollection;
  144.     {only TDialog, TMenuBar, TStringList objects}
  145.     VAR i : integer;
  146.         s40 : String[40];
  147.         Key,Typ : String;
  148.         TOD,TOM,TOS,TOSL : Pointer;
  149.         MyObj : PObject;
  150.         heapav : longint;
  151.     BEGIN
  152.       TOM := TypeOf(TMenuBar);
  153.       TOD := TypeOf(TDialog);
  154.       TOS := TypeOf(TStringList);
  155.       TOSL:= TypeOf(TStatusLine);
  156.  
  157.       IF Collection<>NIL THEN Dispose (Collection,Done);
  158.  
  159.       BufStream := New (PBufStream, Init(ResFileName, stOpenRead, 1024));
  160.       ResFile.Init(BufStream);
  161.       Collection := New(PStringCollection, Init(ResFile.Count,1));
  162.       FOR i := 0 TO ResFile.Count-1 DO
  163.         BEGIN
  164.           heapav := memavail;
  165.           Key := ResFile.KeyAt(i);
  166.           MyObj := ResFile.Get(Key);
  167.           heapav := memavail;
  168.           Typ := '<Derived>       ';
  169.           IF (ResFile.Stream^.status<>stOk) {unregistered object encountered}
  170.             THEN ResFile.Stream^.Reset; {resume stream operation}
  171.           {stream error may also occur if an unregistered object exists
  172.            inside a TDialog object, in this case the heap is not correctly
  173.            cleared}
  174.           IF MyObj<>NIL THEN
  175.             BEGIN
  176.               Typ := '<Other>         ';
  177.               IF TypeOf(MyObj^)=TOM  THEN Typ := '[TMenubar]      ';
  178.               IF TypeOf(MyObj^)=TOD  THEN Typ := '[TDialog]       ';
  179.               IF TypeOf(MyObj^)=TOSL THEN Typ := '[TStatusLine]   ';
  180.               IF TypeOf(MyObj^)=TOS  THEN Typ := '[TStringList]   ';
  181.               Dispose(MyObj,Done);
  182.             END; {IF ResFile.Stream^.status .... THEN ... ELSE ...}
  183.           heapav := memavail;
  184.  
  185.           s40 := Typ+Key;
  186.  
  187.           Collection^.Insert(NewStr(s40));
  188.         END;
  189.  
  190.     END;
  191.  
  192.   DESTRUCTOR TResDialog.Done;
  193.     BEGIN
  194.       Dispose(Collection,Done);
  195.       TDialog.Done;
  196.       ResFile.Done;
  197.     END;
  198.  
  199.   procedure TClickListBox.HandleEvent ( Var Event : TEvent );
  200.     {intercept mouse double click and return cmDoubleClick}
  201.     BEGIN
  202.       IF (Event.What=evMouseDown) AND (Event.Double)
  203.         THEN
  204.           BEGIN
  205.             Event.What := evCommand;
  206.             Event.Command := cmDoubleClick;
  207.             PutEvent(Event);
  208.             ClearEvent(Event);
  209.           END
  210.         ELSE TListBox.HandleEvent(Event);
  211.     END;
  212.  
  213.   procedure TResDialog.Restinit ( FName : PathStr);
  214.     VAR R : TRect;
  215.         View : PView;
  216.     BEGIN
  217.       ResFileName := FName;
  218.       Collection := NIL;
  219.       R.Assign(0,0,0,0);
  220.       RLB := New(PClickListBox,Init(R,1,nil));
  221.       View :=ReplaceControl( PDialog(@Self), RLB, hcResList,
  222.                              TypeOf(TListViewer));
  223.       IF View=NIL THEN
  224.         BEGIN donevideo; writeln ('Replace error' ); halt; end;
  225.       InitCollection;
  226.       RLB^.NewList(Collection);
  227.           writeln ( outfile );
  228.           writeln ( outfile,  'Dump of '+ResFileName+' on ', FDate);
  229.           writeln ( outfile,
  230.               '---------------------------------------------------------');
  231.           writeln ( outfile ); writeln ( outfile );
  232.     END; {PROC TResDialog.RestInit}
  233.  
  234.  
  235.   procedure TResDialog.HandleEvent ( VAR Event : TEvent );
  236.     var s : PString;   todo : word;
  237.         ItemKey : String;
  238.         StreamErrorOccured : boolean;
  239.     BEGIN
  240.  
  241.       TDialog.HandleEvent(Event); {catches cmCancel}
  242.  
  243.       StreamErrorOccured := false;
  244.  
  245.       IF (Event.What=evCommand) THEN
  246.         BEGIN
  247.           IF Event.Command IN
  248.              [cmDAll,cmDDialog,cmDMenubar,cmDStringList,
  249.               cmDStatusLine,cmDFI,cmDoubleClick]
  250.              THEN WaitBox^.Show;
  251.           CASE Event.Command OF
  252.             cmDAll        :
  253.                BEGIN
  254.                  DumpIt ( 'A', '', outfile, ResFile, StreamErrorOccured );
  255.                  ClearEvent(Event);
  256.                END;
  257.             cmDDialog     :
  258.                BEGIN
  259.                  DumpIt ( 'D', '', outfile, ResFile, StreamErrorOccured );
  260.                  ClearEvent(Event);
  261.                END;
  262.             cmDMenubar    :
  263.                BEGIN
  264.                  DumpIt ( 'M', '', outfile, ResFile, StreamErrorOccured );
  265.                  ClearEvent(Event);
  266.                END;
  267.             cmDStatusLine:
  268.                BEGIN
  269.                  DumpIt ( 'L', '', outfile, ResFile, StreamErrorOccured );
  270.                  ClearEvent(Event);
  271.                END;
  272.             cmDStringList :
  273.                BEGIN
  274.                  DumpIt ( 'S', '', outfile, ResFile, StreamErrorOccured );
  275.                  ClearEvent(Event);
  276.                END;
  277.             cmDFI, cmDoubleClick         :
  278.               BEGIN
  279.                 s := PString(RLB^.List^.At(RLB^.focused));
  280.                 ItemKey := copy ( s^, 17,23);
  281.                 DumpIt ( 'F', ItemKey, outfile, ResFile, StreamErrorOccured );
  282.                 ClearEvent(Event);
  283.               END;
  284.             ELSE
  285.           END; {CASE Event.Command}
  286.           IF Event.Command IN
  287.              [cmDAll,cmDDialog,cmDMenubar,cmDStringList,
  288.               cmDStatusLine,cmDFI,cmDoubleClick]
  289.              THEN WaitBox^.Hide;
  290.         END;
  291.  
  292.       IF (Event.What=evKeyDown) AND (Event.KeyCode=kbEnter) THEN
  293.         BEGIN
  294.           s := PString(RLB^.List^.At(RLB^.focused));
  295.           ItemKey := copy ( s^, 17,23);
  296.           DumpIt ( 'F', ItemKey, outfile, ResFile, StreamErrorOccured );
  297.           ClearEvent(Event);
  298.         END;
  299.  
  300.       IF StreamErrorOccured THEN
  301.         messagebox(
  302.           'Stream error in resource file !'#13+
  303.           'Check output file for more info.'#13'Warning: Garbage on heap.',
  304.           nil, mfError+mfOkButton);
  305.  
  306.     END; {PROC TResDialog.HandleEvent}
  307.  
  308.   {--------------------------------------------------}
  309.  
  310. { TFileStatusBox }
  311.  
  312.   PROCEDURE TFileStatusBox.Draw;
  313.     {nonlocal: MyApp.OutFileName,ResFileName}
  314.     VAR Params : ARRAY[0..1] OF Pointer;
  315.         name1,name2 : String[15];
  316.         Result : String;
  317.         i,l : integer;
  318.     BEGIN
  319.       Name1 := FBase(MyApp.ResFileName); l := length(Name1);
  320.       FOR i := 1 TO 15-l DO Name1 := ' '+Name1;
  321.       Params[0] := @Name1;
  322.       Name2 := FBase(MyApp.OutFileName)+'              ';
  323.       Params[1]:= @Name2;
  324.       FormatStr ( Result, '%15s --> %15s', Params);
  325.       writestr(0,0,Result,7);
  326.     END;
  327.  
  328.  
  329. { Waitbox }
  330.  
  331.   FUNCTION TWaitDialog.GetPalette : PPalette;
  332.     {static text blinks, frame }
  333.     CONST s : String[length(CGrayDialog)] = CGrayDialog;
  334.     VAR i : integer;
  335.     BEGIN
  336.       i := length(Application^.GetPalette^);
  337.       s[1] := chr(i-1); s[2] := chr(i-1); s[6] := chr(i);
  338.       GetPalette := PPalette(@s);
  339.     END; {FUNC TWaitBox.GetPalette}
  340.  
  341.  
  342. { TMyApp}
  343.  
  344.   constructor TMyApp.Init;
  345.    VAR InitEvent : TEvent;
  346.        R, R1 : TRect;
  347.  
  348.     begin {Init}
  349.  
  350.       MyAppResStream := New(PBufStream, Init(BRSName, stOpenRead, 4096));
  351.       MyAppResFile.Init(MyAppResStream);
  352.  
  353.       HCTEXT_SL := PStringList(MyAppResFile.Get('RESDUMP_HT'));
  354.  
  355.       TApplication.Init;
  356.  
  357.  
  358.       ScrnSaverKickTime := 0;                                          {+++}
  359.       ScrnSaverLastTime := 0;                                          {+++}
  360.       ScrnSaverMode := false;                                          {+++}
  361.       GraceCounter :=0;                                                {+++}
  362.  
  363.       OutFileName := 'RESDUMP.OUT'; {default output name}
  364.       ResFileName := '';
  365.       OutFileOpen := false; ResFileOpen := false;
  366.  
  367.       GetExtent(R);
  368.       R.A.X := R.B.X - 49; R.B.X := R.B.X - 40;
  369.       R.B.Y := R.A.Y + 1;
  370.       Clock := New(PClockView, Init(R));
  371.       Insert(Clock);
  372.  
  373.       GetExtent(R);
  374.       Dec(R.B.X);
  375.       R.A.X := R.B.X - 9; R.A.Y := R.B.Y - 1;
  376.       Heap := New(PHeapView, Init(R));
  377.       Insert(Heap);
  378.  
  379.       GetExtent(R1);
  380.       R1.A.X := R1.B.X-35; R1.B.Y := R1.A.Y+1;
  381.  
  382.       FBox := New(PFileStatusBox,Init(R1));
  383.       IF ValidView(FBox)<>NIL THEN Insert(FBox);
  384.  
  385.       {insert waitbox in desktop, but do not show now}
  386.       WaitBox := nil;
  387.       IF LowMemory
  388.         THEN OutOfMemory
  389.         ELSE
  390.           BEGIN
  391.             RDialog.VMTLink := Ofs(TypeOf(TWaitDialog)^);
  392.             WaitBox := PDialog(MyAppResFile.Get('WAITBOX_DB'));
  393.             RDialog.VMTLink := Ofs(TypeOf(TDialog)^);
  394.           END;
  395.        IF ValidView(WaitBox) <> NIL THEN
  396.          BEGIN
  397.            WaitBox^.SetState(sfVisible OR sfShadow,false);
  398.            Insert(WaitBox); {insert into application}
  399.          END;
  400.  
  401.       WITH InitEvent DO
  402.         BEGIN What := evCommand; Command := cmNewOutFileD; END;
  403.       PutEvent ( InitEvent );
  404.  
  405.     end;  {Init}
  406.  
  407.  
  408.   PROCEDURE TMyApp.InitMenuBar;
  409.     BEGIN
  410.       MenuBar := PMenuBar(MyAppResFile.Get('RESDUMP_MB'));
  411.       IF MenuBar=NIL THEN {no error checking done!}
  412.     END;{PROC TMyApp.InitMenuBar}
  413.  
  414.  
  415.   procedure TMyApp.InitStatusLine;
  416.     var R : TRect;
  417.     begin  {InitStatusLine}
  418.       RStatusLine.VMTLink := Ofs(TypeOf(TMyStatusLine)^);
  419.       StatusLine := PStatusLine(MyAppResFile.Get('RESDUMP_ST'));
  420.       RStatusline.VMTLink := Ofs(TypeOf(TStatusLine)^);
  421.       IF Statusline=NIL THEN {no error checking done!}
  422.     end; {InitStatusLine}
  423.  
  424.   PROCEDURE TMyApp.Idle;
  425.     BEGIN
  426.       inherited Idle;
  427.  
  428.       IF ScrnSaverMode                                                 {+++}
  429.        THEN                                                            {+++}
  430.         BEGIN                                                          {+++}
  431.           IF ((Time-ScrnSaverLastTime)>ScrnSaverInt) THEN              {+++}
  432.             BEGIN                                                      {+++}
  433.               ClrScr;                                                  {+++}
  434.               TextColor(Random(14)+1);                                 {+++}
  435.               Gotoxy ( Random(80-length(ScrnSaverText)), Random(24));  {+++}
  436.               write ( ScrnSaverText ); ScrnSaverLastTime := Time;      {+++}
  437.             END;                                                       {+++}
  438.         END                                                            {+++}
  439.       ELSE                                                             {+++}
  440.         BEGIN                                                          {+++}
  441.           Heap^.Update; Clock^.Update;                                 {+++}
  442.         END;                                                           {+++}
  443.  
  444.     END;{PROC TMyApp.Idle}
  445.  
  446.  
  447.   destructor TMyApp.Done;
  448.     begin {Done}
  449.       IF OutFileOpen THEN close ( outfile );
  450.       TApplication.Done
  451.     end;  {Done}
  452.  
  453.   procedure TMyApp.GetEvent ( VAR Event : TEvent );
  454.     VAR p : pointer; SEvent : TEvent;
  455.     BEGIN
  456.       inherited GetEvent(Event);
  457.  
  458.       {Reset counter if event pending but do not kill this event      +++}
  459.       IF Event.What<>evNothing THEN                                  {+++}
  460.         BEGIN                                                        {+++}
  461.           GraceCounter := 0; ScrnSaverKickTime := 0;                 {+++}
  462.           IF ScrnSaverMode THEN                                      {+++}
  463.             BEGIN                                                    {+++}
  464.               SEvent.What := evcommand;                              {+++}
  465.               SEvent.command := cmStopScrnSaver;                     {+++}
  466.               HandleEvent(SEvent);                                   {+++}
  467.               Exit;                                                  {+++}
  468.             END;                                                     {+++}
  469.         END;                                                         {+++}
  470.  
  471.       IF NOT ScrnSaverMode THEN                                      {+++}
  472.        IF GraceCounter < GracePeriod    {start calling DOS time after +++}
  473.         THEN Inc(GraceCounter)          {grace period since it's too  +++}
  474.         ELSE                            {time consuming.              +++}
  475.           BEGIN
  476.             IF ScrnSaverKickTime=0 THEN ScrnSaverKickTime := Time;   {+++}
  477.             IF ((Time-ScrnSaverKickTime)>ScrnSaverDelay) THEN        {+++}
  478.               BEGIN                                                  {+++}
  479.                 SEvent.What := evcommand;                            {+++}
  480.                 SEvent.command := cmStartScrnSaver;                  {+++}
  481.                 HandleEvent(SEvent);                                 {+++}
  482.                 Exit;                                                {+++}
  483.              END;                                                    {+++}
  484.           END;                                                       {+++}
  485.  
  486.     END; {PROC TMyApp.GetEvent}
  487.  
  488.  
  489.   procedure TMyApp.HandleEvent(var Event: TEvent);
  490.  
  491.     begin {HandleEvent}
  492.  
  493.       TApplication.HandleEvent(Event);
  494.       if (Event.What = evCommand) then
  495.          begin
  496.            case Event.Command of
  497.             cmAboutDialog :
  498.                AboutDialog;
  499.             cmDumpDialog :
  500.                DumpDialog;
  501.             cmNewOutFileD : BEGIN
  502.                               OutFileDialog;
  503.                               Event.command := cmDumpDialog; PutEvent(Event);
  504.                             END;
  505.             cmStartScrnSaver :                                   {+++}
  506.                BEGIN                                             {+++}
  507.                  ScrnSaverLastTime := 0;                         {+++}
  508.                  ScrnSaverMode := true;                          {+++}
  509.                  TextBackGround(Black);                          {+++}
  510.                END;                                              {+++}
  511.             cmStopScrnSaver :                                    {+++}
  512.                IF ScrnSaverMode THEN                             {+++}
  513.                  BEGIN                                           {+++}
  514.                    ScrnSaverMode := false;                       {+++}
  515.                    ScrnSaverKickTime := 0; GraceCounter := 0;    {+++}
  516.                    inherited redraw;                             {+++}
  517.                  END;                                            {+++}
  518.             else
  519.                Exit;
  520.            end;
  521.            ClearEvent(Event);
  522.          end
  523.  
  524.     end;  {HandleEvent}
  525.  
  526.  
  527. function TMyApp.GetPalette: PPalette;
  528.   const
  529.     CWaitColor=#$50#$F4;
  530.     CNewColor = CAppColor + CWaitColor;
  531.     CNewBlackWhite = CAppBlackWhite + CWaitColor;
  532.     CNewMonochrome = CAppMonochrome + CWaitColor;
  533.     P: array[apColor..apMonochrome] of string[Length(CNewColor)] =
  534.       (CNewColor, CNewBlackWhite, CNewMonochrome);
  535.   begin
  536.     GetPalette := @P[AppPalette];
  537.   end;
  538.  
  539.  
  540.   procedure TMyApp.AboutDialog;
  541.     var
  542.       Dialog   : PDialog;
  543.       C        : word;
  544.  
  545.     begin {AboutDialog}
  546.  
  547.       Dialog := PDialog(MyAppResFile.Get('ABOUT_DB'));
  548.       IF ValidView(Dialog)<>nil THEN
  549.         BEGIN
  550.           C := DeskTop^.ExecView(Dialog);
  551.           Dispose(Dialog,Done);
  552.         END;
  553.  
  554.     end;  {AboutDialog}
  555.  
  556.  
  557.   procedure TMyApp.DumpDialog;
  558.  
  559.     var
  560.       R          : TRect;
  561.       Dialog     : PResDialog;
  562.       D          : PFileDialog;
  563.       View       : PView;
  564.       C          : word;
  565.       ResDir : DirStr; ResName : NameStr; ResExt : ExtStr;
  566.       ResFullName : String;
  567.  
  568.     begin {DumpDialog}
  569.  
  570.       D := New (PFileDialog, Init('*.BRS', 'Open Resource File',
  571.                 '~N~ame',fdOpenButton,100));
  572.       D^.HelpCtx := hcResFile;
  573.       IF ValidView(D)<>NIL THEN
  574.         BEGIN
  575.           IF DeskTop^.ExecView(D) <> cmCancel THEN
  576.             BEGIN
  577.               D^.GetFileName(ResFileName);
  578.               FSplit(ResFileName,ResDir,ResName,ResExt);
  579.               ResFileName := ResDir+ResName+ResExt;
  580.               FBox^.drawview;
  581.  
  582.               {fool Stream mechanism, works for TDialog derivatives}
  583.                 RDialog.VMTLink := Ofs(TypeOf(TResDialog)^);
  584.                 Dialog := PResDialog(MyAppResFile.Get('SELECT_DB'));
  585.                 RDialog.VMTLink := Ofs(TypeOf(TDialog)^);
  586.                 Dialog^.RestInit(ResFileName);
  587.                 C := DeskTop^.ExecView(Dialog);
  588.                 Dispose(Dialog,Done);
  589.  
  590.               ResFileName := '';
  591.               FBox^.drawview;
  592.  
  593.             END;
  594.  
  595.           Dispose(D,Done);
  596.  
  597.         END;
  598.  
  599.     end;  {PROC DumpDialog}
  600.  
  601.  
  602.   procedure TMyApp.OutFileDialog;
  603.  
  604.     var
  605.       Dialog   : PFileDialog;
  606.       OutFD    : PDialog;
  607.       todo, c  : word;
  608.       Param : Pointer;
  609.       FullName : PathStr;
  610.       Dir : DirStr; Ext : ExtStr; Name : NameStr;
  611.       Again, AppendToOldOutFile : boolean;
  612.  
  613.     begin {OutFileDialog}
  614.  
  615.       Dialog := New (PFileDialog, Init(OutFileName, 'Open Output File',
  616.                     '~N~ame',fdOpenButton,101));
  617.       Dialog^.HelpCtx := hcOutFile;
  618.  
  619.       FullName := '';
  620.       Again := true;
  621.       IF ValidView(Dialog)=NIL
  622.        THEN BEGIN DoneVideo; writeln ('ValidView error.'); halt; END
  623.        ELSE
  624.        BEGIN
  625.         WHILE Again DO
  626.          BEGIN
  627.           IF DeskTop^.ExecView(Dialog) <> cmCancel
  628.            THEN
  629.             BEGIN
  630.               Dialog^.GetFileName (FullName);
  631.               Again := false; AppendToOldOutFile := false;
  632.               IF FullName<>'' THEN
  633.                 BEGIN
  634.                   {do this to trim length}
  635.                   FSplit(FullName,Dir,Name,Ext);
  636.                   FullName := Dir+Name+Ext;
  637.                   IF FileExist(FullName) THEN
  638.                     BEGIN
  639.                       OutFD := PDialog(MyAppResFile.Get('OUTFILE_DB'));
  640.                       IF ValidView(OutFD)<>nil THEN
  641.                         BEGIN
  642.                           todo := DeskTop^.ExecView(OutFD);
  643.                           {cmYes: append, cmCancel: other name,
  644.                            cmOk or cmNo: overwrite output file}
  645.                           AppendToOldOutFile := (todo=cmYes);
  646.                           Dispose(OutFD,Done);
  647.                         END;
  648.                       Again := (todo = cmCancel);
  649.                     END; {IF bFileExist ...}
  650.                 END; {IF FullName<>'' ...}
  651.             END {IF DeskTop^.ExecView(D)<>...}
  652.            ELSE
  653.              c := messagebox( 'You must choose an output file.', nil,
  654.                               mfInformation+mfOkButton );
  655.          END; {WHILE Again DO ...}
  656.  
  657.          Dispose(Dialog,Done);
  658.  
  659.        END; {IF ValidView(D) ... ELSE ...}
  660.  
  661.       IF FullName<>OutFileName THEN
  662.         BEGIN
  663.           IF OutFileOpen THEN
  664.             BEGIN close(outfile); OutFileOpen := false END;
  665.           OutFileName := FullName; FBox^.drawview;
  666.         END;
  667.  
  668.       IF NOT OutFileOpen THEN
  669.         BEGIN
  670.           {open for append}
  671.           Assign ( outfile, OutFileName );
  672.           {$I-}
  673.           IF AppendToOldOutFile
  674.             THEN Append(outfile)
  675.             ELSE rewrite(outfile);
  676.           {$I+}
  677.           IF IOResult<>0 THEN
  678.             BEGIN  donevideo; writeln ( 'Output file error'); halt END;
  679.           OutFileOpen := true;
  680.         END;
  681.     end;  {OutFileDialog}
  682.  
  683.  
  684.  
  685.   begin {RESDUMP}
  686.  
  687.     IF Lo(DosVersion) >= 3
  688.       THEN EXEName := ParamStr(0)
  689.       ELSE
  690.         BEGIN
  691.           PrintStr ( 'Need DOS version > 3 !!'); halt
  692.         END;
  693.  
  694.     FSplit(FExpand(EXEName),Ed,En,Ee);
  695.     BRSName := Ed+En+'.BRS';
  696.  
  697.     RegisterDialogs;
  698.     RegisterObjects;
  699.     RegisterViews;
  700.     RegisterMenus;
  701.     RegisterType(RStringList);
  702.     RegisterType(RSortedListBox);
  703.  
  704.     MyApp.Init;
  705.     MyApp.Run;
  706.     MyApp.Done;
  707.  
  708.   end.  {RESDUMP}
  709.  
  710.